home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / HUGS1 / hs / fastsort < prev    next >
Text File  |  1995-02-14  |  2KB  |  42 lines
  1. {- list sorting: see L.C.Paulson, ML for the working programmer, Cambidge, p100
  2. -- The list is split into ascending chunks which are then merged in pairs.
  3.  
  4. samsort l = sorting [] 0 l
  5.   where sorting ls k []         = head(mergepairs ls 0)
  6.         sorting ls k (x:xs)     = sorting (mergepairs (run:ls) kinc) kinc tl
  7.           where (run, tl)       = nextrun [x] xs
  8.                 kinc            = k+1
  9.         nextrun run []          = (reverse run, [])
  10.         nextrun rs@(r:_) xl@(x:xs)
  11.                 | x<r           = (reverse rs, xl)
  12.                 | otherwise     = nextrun (x:rs) xs
  13.         mergepairs [l] _ = [l]
  14.         mergepairs lx@(l1:l2:ls) k
  15.                 | k`mod`2 == 1  = lx
  16.                 | otherwise     = mergepairs((merge l1 l2):ls) (k/2)
  17. -}
  18.  
  19. -- this mergesort uses a partioning mechanism like quicksort to build
  20. -- longer initial sequences. It also uses a non-counting mergePairs.
  21. -- Bob Buckley 30-MAR-93 (Bob.Buckley@levels.unisa.edu.au)
  22.  
  23. msort xs = mergePhase (runPhase xs)
  24.   where mergePhase [x]          = x
  25.         mergePhase [x,y]        = merge x y     -- redundant case
  26.         mergePhase l            = mergePhase (mergePairs l)
  27.         mergePairs [x1,x2]      = [merge x1 x2] -- redundant case
  28.         mergePairs (x1:x2:xs)   = merge x1 x2 : mergePairs xs
  29.         mergePairs l            = l             -- note: l=[] or l=[_]
  30.         runPhase []     = [[]]
  31.         runPhase (e:es) = takeAsc [e] es
  32.         takeAsc asc []  = [reverse asc]
  33.         takeAsc xs@(x:_) zs@(z:zr)
  34.                 | x<=z          = takeAsc (z:xs) zr
  35.                 | otherwise     = takeDec xs [z] zr
  36.         takeDec asc dec []      = [merge (reverse asc) dec]
  37.         takeDec xs@(x:_) ys@(y:_) zs@(z:zr)
  38.                 | z<y           = takeDec xs (z:ys) zr
  39.                 | x<=z          = takeDec (z:xs) ys zr
  40.                 | otherwise     = merge (reverse xs) ys : runPhase zs
  41.  
  42.